home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / PowerLisp 1.1 / Library / graphics.lisp < prev    next >
Encoding:
Text File  |  1994-02-17  |  2.5 KB  |  110 lines  |  [TEXT/ROSA]
  1. ;;;;
  2. ;;;;    PowerLisp graphics routines
  3. ;;;;    Copyright (c) 1994 Roger Corman
  4. ;;;;
  5.  
  6. (defpackage graphics
  7.     (:use :common-lisp)
  8.     (:export 
  9.         open-canvas 
  10.         use-canvas 
  11.         moveto 
  12.         lineto
  13.         setcolor
  14.         pensize
  15.         fillrect
  16.         fillpoly
  17.         clear-canvas))
  18.  
  19. (in-package :graphics)
  20. (provide :graphics)
  21.  
  22. (defvar *current-canvas* nil)
  23. (defvar *current-point* nil)
  24. (defvar *current-color* nil)
  25.  
  26. (defun open-canvas (canvas-name)
  27.     "Usage: (open-canvas canvas-name)
  28.         Creates a canvas with the requested name."
  29.     (%new-canvas canvas-name)
  30.     (setq *current-point* nil)
  31.     (setq *current-canvas* canvas-name))
  32.  
  33. (defun use-canvas (canvas-name)
  34.     "Usage: (use-canvas canvas-name)
  35.         Makes the requested canvas the current canvas."
  36.     (setq *current-point* nil)
  37.     (setq *current-canvas* canvas-name))
  38.  
  39. (defun moveto (x y)
  40.     "Usage: (moveto x y)
  41.         x and y should be integers and are relative to the upper left
  42.         corner of the canvas." 
  43.     (setq *current-point* (cons x y)))
  44.  
  45. (defun lineto (x y)
  46.     "Usage: (lineto x y)
  47.         x and y should be integers and are relative to the upper left
  48.         corner of the canvas." 
  49.     (unless *current-point*
  50.         (error "No current point"))
  51.     (%line *current-canvas* 
  52.         (car *current-point*)
  53.         (cdr *current-point*)
  54.         x y)
  55.     (setq *current-point* (cons x y)))
  56.  
  57. (defun setcolor (r g b)
  58.     "Usage: (setcolor red green blue)
  59.         Sets the current canvas color to the requested RGB color.
  60.         Red, green and blue should be between 0.0 and 1.0"
  61.     (let ((red (truncate (* r 65535)))
  62.           (green (truncate (* g 65535)))
  63.           (blue (truncate (* b 65535))))
  64.         (%rgbforecolor *current-canvas* red green blue)
  65.         (setq *current-color* (list red green blue)))) 
  66.  
  67. (defun pensize (size)
  68.     "Usage: (pensize size)
  69.         The current canvas pen size is set to the requested dimension.
  70.         size should be an integer." 
  71.     (%pensize *current-canvas* size size))
  72.  
  73. (defun fillrect (x1 y1 x2 y2)
  74.     "Usage: (fillrect x1 y1 x2 y2)
  75.         A filled rectangle as drawn on the current canvas, using
  76.         the current color." 
  77.     (%fill-polygon *current-canvas* 
  78.         `((,x1 . ,y1) (,x2 . ,y1) (,x2 . ,y2) (,x1 . ,y2))))
  79.  
  80. (defun fillpoly (&rest points)
  81.     "Usage: (fillpoly points)
  82.         A filled polygon as drawn on the current canvas, using
  83.         the current color.
  84.         The points list is a list of cons pairs where each cons contains
  85.         two integers (x and y)." 
  86.     (%fill-polygon *current-canvas* points))
  87.  
  88. (defun clear-canvas () 
  89.     "Usage: (clear-canvas)
  90.         The current canvas is erased."
  91.     (%erase-canvas *current-canvas*))
  92.  
  93. ;;;;    Import all these symbols into Common Lisp package
  94. (in-package :common-lisp)
  95.  
  96. (use-package :graphics)
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.